home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / eulisp / mpfeel.lha / MPFeel / Modules / eulinda.em < prev    next >
Lisp/Scheme  |  1992-10-06  |  5KB  |  187 lines
  1. ;; A simple Linda implementation
  2. ;; RJB March 92
  3.  
  4. ;; (make-linda-pool)
  5. ;; (linda-out pool tag . values)
  6. ;; (linda-in pool tag . pattern)
  7. ;; (linda-read pool tag . pattern)
  8. ;; (linda-eval fun . args)
  9.  
  10. ;; the pattern (? var) matches anything, and assigns that value to var
  11. ;; the pattern ? matches anything, and discards the value
  12. ;; tags, and any other patterns are matched literally
  13.  
  14. ;; e.g.
  15. ;; (setq pp (make-linda-pool))
  16. ;; (linda-out pp 'foo 1 2)
  17. ;; (linda-read pp 'foo ? (? x))      setqs x to 2
  18. ;; (linda-read pp 'foo 1 2 3)        suspends
  19.  
  20. (defmodule eulinda (standard0) ()
  21.  
  22.   (deflocal trace-linda-p ())
  23.  
  24.   (defun tril (x) (setq trace-linda-p x))
  25.  
  26.   (defstruct linda-pool ()
  27.     ((lock initform (make-semaphore)
  28.        accessor linda-pool-lock)
  29.      (tuple-table initform (make-linda-tuple-table)
  30.           accessor linda-pool-tuple-table))
  31.     constructor make-linda-pool)
  32.  
  33.   (defun print-linda-pool (pool)
  34.     (format t "#< ")
  35.     (map-table
  36.      (lambda (k v) (format t "~a " v))
  37.      (linda-pool-tuple-table pool))
  38.     (format t ">~%"))
  39.  
  40.   (defmacro linda-in (pool tag . pattern)
  41.     `(let ((*tuple* (convert (linda-tuple-value
  42.                   (linda-in-primitive ,pool ,tag
  43.                           ,@(tidy-pattern pattern)))
  44.                  vector)))
  45.        ,@(do-setqs pattern)
  46.        *tuple*))
  47.  
  48.   (defun tidy-pattern (pat)
  49.     (cond ((null pat) ())
  50.       ((eq (car pat) '?)
  51.        (cons '? (tidy-pattern (cdr pat))))
  52.       ((and (consp (car pat))
  53.         (eq (caar pat) '?))
  54.        (cons '? (tidy-pattern (cdr pat))))
  55.       (t (cons (car pat) (tidy-pattern (cdr pat))))))
  56.  
  57.   (defun do-setqs-aux (pattern n)
  58.     (cond ((null pattern) ())
  59.       ((and (consp (car pattern))
  60.         (eq (caar pattern) '?))
  61.        (cons `(setq ,(cadar pattern) (vector-ref *tuple* ,n))
  62.          (do-setqs-aux (cdr pattern) (+ n 1))))
  63.       (t (do-setqs-aux (cdr pattern) (+ n 1)))))
  64.  
  65.   (defun do-setqs (pattern)
  66.       (do-setqs-aux pattern 0))
  67.  
  68.   (defun linda-in-primitive (pool tag . pattern)
  69.     (when trace-linda-p (format t ";; in-ing ~a ~a~%" tag pattern))
  70.     (let ((val (linda-in/read pool tag (tuple tag pattern) in-match)))
  71.       (when trace-linda-p
  72.     (format t ";; in'd ~a~%" val))
  73.       val))
  74.  
  75.   (defmacro linda-read (pool tag . pattern)
  76.     `(let ((*tuple* (convert (linda-tuple-value
  77.                   (linda-read-primitive ,pool ,tag
  78.                  ,@(tidy-pattern pattern)))
  79.                  vector)))
  80.        ,@(do-setqs pattern)
  81.        *tuple*))
  82.  
  83.   (defun linda-read-primitive (pool tag . pattern)
  84.     (when trace-linda-p (format t ";; reading ~a ~a~%" tag pattern))
  85.     (let ((val (linda-in/read pool tag (tuple tag pattern) read-match)))
  86.       (when trace-linda-p
  87.     (format t ";; read ~a~%" val))
  88.       val))
  89.  
  90.   (defun linda-in/read (pool tag pattern matchfn)
  91.     (let ((lock (linda-pool-lock pool)))
  92.       (open-semaphore lock)
  93.       (let ((match (matchfn pool tag pattern)))
  94.     (close-semaphore lock)
  95.     (if (null match)
  96.         (progn
  97.           (when trace-linda-p
  98.         (format t ";; suspending~%"))
  99.           (thread-reschedule)
  100.           (when trace-linda-p
  101.         (format t ";; retrying ~a ~a~%" tag
  102.             (linda-tuple-value pattern)))
  103.           (linda-in/read pool tag pattern matchfn))
  104.         match))))
  105.  
  106.   (defun linda-out (pool tag . rest)
  107.     (when trace-linda-p (format t ";; out ~a ~a~%" tag rest))
  108.     (let ((lock (linda-pool-lock pool))
  109.       (tup (tuple tag rest)))
  110.       (open-semaphore lock)
  111.       (linda-tuple-out pool tag tup)
  112.       (close-semaphore lock)
  113.       (thread-reschedule)
  114.       tup))
  115.  
  116.   (defun make-linda-tuple-table ()
  117.     (make-table equal))
  118.  
  119.   (defstruct linda-tuple ()
  120.     ((tag initarg tag
  121.       reader linda-tuple-tag)
  122.      (value initarg value
  123.         reader linda-tuple-value))
  124.     constructor (tuple tag value))
  125.  
  126.   (defmethod generic-write ((lt linda-tuple) s)
  127.     (format s "#<linda-tuple: ~a ~a>"
  128.         (linda-tuple-tag lt)
  129.         (linda-tuple-value lt)))
  130.  
  131.   (defmethod generic-prin ((lt linda-tuple) s)
  132.     (format s "#<linda-tuple: ~a ~a>"
  133.             (linda-tuple-tag lt)
  134.             (linda-tuple-value lt)))
  135.  
  136.   (defun delete1 (obj lis)
  137.     (cond ((null lis) ())
  138.       ((eq obj (car lis)) (cdr lis))
  139.       (t (cons (car lis) (delete1 obj (cdr lis))))))
  140.  
  141.   (defun in-match (pool tag pattern-tuple)
  142.     (let* ((table (linda-pool-tuple-table pool))
  143.        (vallist (table-ref table tag))
  144.        (val (match-in-list (linda-tuple-value pattern-tuple) vallist)))
  145.       (unless (null val)
  146.     ((setter table-ref) table tag (delete1 val vallist)))
  147.       val))
  148.  
  149.   (defun read-match (pool tag pattern-tuple)
  150.     (let* ((table (linda-pool-tuple-table pool))
  151.            (vallist (table-ref table tag)))
  152.       (match-in-list (linda-tuple-value pattern-tuple) vallist)))
  153.  
  154.   (defun match-in-list (pat vallist)
  155.     (cond ((null vallist) ())
  156.       ((matchit pat (linda-tuple-value (car vallist))) (car vallist))
  157.       (t (match-in-list pat (cdr vallist)))))
  158.  
  159.   (defun matchit (pat val)
  160.     (cond ((null pat) t)
  161.       ((null val) ())
  162.       ((equal (car pat) (car val))
  163.        (matchit (cdr pat) (cdr val)))
  164.       ((eq (car pat) '?)
  165.        (matchit (cdr pat) (cdr val)))
  166.       (t ())))
  167.  
  168.   (defun linda-tuple-out (pool tag tuple)
  169.     (let* ((table (linda-pool-tuple-table pool))
  170.            (val (table-ref table tag)))
  171.       ((setter table-ref) table tag (nconc val (list tuple)))
  172.       tuple))
  173.  
  174.   (defun linda-eval (fun . args)
  175.     (apply thread-start (make-thread fun) args))
  176.  
  177.   ; a convenient fiddle
  178.   (defconstant ? '?)
  179.  
  180.   (export make-linda-pool linda-in linda-read linda-out linda-eval)
  181.   (export linda-in-primitive linda-read-primitive)
  182.   (export linda-tuple-value ?)
  183.  
  184.   (export print-linda-pool tril)
  185.  
  186. )
  187.